# flickr.tcl -- Flickr API
#
#	This module is a low-level wrapper around the flickr API.  It
#	is based on top of the REST API.
#
# Copyright (c) 2006 by the Swedish Institute of Computer Science.
#
# See the file 'license.terms' for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.4
package require http
package require md5

package require uobj; # uobj is a helper package for object-like interfaces.
package require tax;  # tax is a micro-XML parser


# TODO:
#
# DONE - Implement authentification features and support for
# read/write/delete permissions.
#
# DONE - Add all API methods, only a few are implemented so far.
#
# DONE - Use reflection to declare all methods automatically?
#
# Implement better interface for results and result parsing.
# Linearise a tree of the XML response? Something else?

namespace eval ::flickr {
    variable Flickr
    if { ! [info exists Flickr] } {
	array set Flickr {
	    -key          ""
	    -secret       ""
	    -rest         "http://www.flickr.com/services/rest/"
	    -auth         ""
	    cache         "api.tcl"
	    skip          "flickr.auth.* flickr.reflection.*"
	    idgene        0
	}
	variable libdir [file dirname [file normalize [info script]]]
	::uobj::install_log flickr Flickr; # Creates 'log' ns variable
	::uobj::install_defaults flickr Flickr
    }
}


# ::flickr::__signature -- Sign method call
#
#	This procedure compute the signature of a method call using
#	the shared secret coming from the flickr site.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	args	List of array set-like arguments
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::flickr::__signature { cx args } {
    variable Flickr
    variable log

    # Get to context 
    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    upvar \#0 $cx FlickrCx

    set auth $FlickrCx(-secret)
    if { [llength $args] > 0 } {
	array set arguments $args
	foreach k [lsort [array names arguments]] {
	    append auth $k
	    append auth $arguments($k)
	}
    }

    return [string tolower [::md5::md5 -hex $auth]]
}


# ::flickr::__extractxml -- Store XML answer in context
#
#	This procedure is designed to be called back by internal
#	functions and for the analysis of XML answers coming from
#	Flickr.  The procedure complies to the callback arguments of
#	the tax parser.  It stores the results of some calls into the
#	connection context for further usage.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	extag	Name of XML tag to extract from response
#	idx	Name of index in connection context to append XML body val to.
#	tag	Name of tag being called back
#	type	Type of tag (open, close, etc.)
#	props	Properties to tag
#	bdy     Body (content) of tag being parsed
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::flickr::__extractxml { cx extag idx tag type props bdy tree } {
    variable Flickr
    variable log

    if { [string first "O" $type] >= 0 } {
	if { $tag eq $extag } {
	    if { [info vars $cx] ne "" } {
		upvar \#0 $cx FlickrCx
		lappend FlickrCx($idx) [string trim $bdy]
	    }
	}
    }
}


# ::flickr::loginurl -- Generate login URL
#
#	This procedure implements the first step of the login
#	procedure.  It generates the login url that the user should be
#	directed to for logging in and allowing an application to
#	manipulate his/her account.  The "frob" for the authorisation
#	context is generated if necessary.  It is both stored in the
#	connection context and can be passed back to the caller if
#	necessary.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	perms	Permissions requested (read, write, delete)
#	frob	Frob for authorisation, empty to generate one.
#	frob_p	Pointer to variable that will contain the generated frob.
#
# Results:
#	Return the URL for logging in and authorizing the application
#	to access an account, an empty string on errors.
#
# Side Effects:
#	The frob is stored in the connection context for further use
proc ::flickr::loginurl { cx perms { frob "" } { frob_p ""} } {
    variable Flickr
    variable log

    # Get to context 
    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    upvar \#0 $cx FlickrCx

    # Get to main authorisation URL, generate it from the -rest option
    # if empty.
    if { $FlickrCx(-auth) eq "" } {
	set auth [regsub rest $FlickrCx(-rest) auth]
    } else {
	set auth $FlickrCx(-auth)
    }

    # Generate a frob if we don't have one, use the context for
    # storing it.
    if { $frob eq "" } {
	${log}::notice "Automatically requesting for a frob"
	set FlickrCx(frob) ""
	auth.getFrob $cx [list __extractxml $cx frob frob]
	set frob $FlickrCx(frob); # Leave the frob in the context
    } else {
	set FlickrCx(frob) $frob
    }

    # We have a frob, generate the login URL that the user should
    # follow to authorize the application to access its account.
    if { $frob ne "" } {
	# Be sure we can pass further the frob to the caller
	if { $frob_p ne "" } {
	    upvar $frob_p f
	    set f $frob
	}
	# Now generate the URL according to the Flickr API
	# documentation at
	# http://www.flickr.com/services/api/auth.howto.desktop.html
	set call [list "api_key" $FlickrCx(-key) \
		      "perms" $perms "frob" $frob]
	lappend call "api_sig" [eval __signature $cx $call]
	set q [eval ::http::formatQuery $call]
	return "${auth}?${q}"
    }
    
    # Return an empty URL on problems.
    return ""
}

# ::flickr::authorize -- Finalize authorisation
#
#	This procedure will finalise authorisation, it is a wrapper
#	around flickr.auth.getToken.  The procedure implements the
#	second step of the authorization procedure (see loginurl
#	above).  The authorisation token is both returned and stored
#	in the connection context.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	frob	Flickr identifier for the authorisation request, empty to use
#               the one from the context.
#
# Results:
#	Return the authorisation token, empty string on problems.
#
# Side Effects:
#	The authorisation token is stored in the connection context,
#	so that it can be used by API calls that need it.
proc ::flickr::authorize { cx { frob "" } } {
    variable Flickr
    variable log

    # Get to context 
    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    upvar \#0 $cx FlickrCx

    # If we do not have a frob in the arguments, try to look for it in
    # the context.
    if { $frob eq "" } {
	if { [array names FlickrCx frob] ne "" } {
	    set frob $FlickrCx(frob)
	}
    }
    
    # We have a frob, complete the authorisation process and store the
    # token for further usage.
    if { $frob ne "" } {
	auth.getToken $cx [list __extractxml $cx token token]
	return $FlickrCx(token)
    }

    return ""
}


# ::flickr::call -- Call a flickr method and get its results
#
#	This command call a flickr method and returns back its results.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	meth	Name of method to call
#	args	List of array set-like arguments
#
# Results:
#	None
#
# Side Effects:
#	None.
proc ::flickr::call { cx meth sign login args } {
    variable Flickr
    variable log

    # Get to context 
    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    upvar \#0 $cx FlickrCx

    # Construct REST query string according to flickr API doc.
    set call [list "method" $meth "api_key" $FlickrCx(-key)]
    foreach { key val } $args {
	lappend call $key $val
    }
    if { [string is true $login] } {
	if { [array names FlickrCx token] eq "" } {
	    ${log}::error "You are not logged in into the Flickr Web site"
	} else {
	    lappend call "auth_token" $FlickrCx(token)
	    set sign on
	}
    }
    if { [string is true $sign] } {
	lappend call "api_sig" [eval __signature $cx $call]
    }
    set q [eval ::http::formatQuery $call]

    # Now performs call and gather results
    ${log}::debug "Calling flickr method $meth with args: $args"
    set token [::http::geturl $FlickrCx(-rest) -query $q]
    if { [::http::status $token] eq "ok" } {
	set data [::http::data $token]
	::http::cleanup $token
	return $data
    } else {
	${log}::warn "Could not call $meth at flickr"
    }

    return ""
}


# ::flickr::__checkargs -- Check incoming arguments
#
#	This command check the incoming arguments of a method call
#	against an argument template that specifies which arguments
#	are allowed and whether they are optional or mandatory.  The
#	template is a list where optional arguments are preceeded by a
#	question mark, e.g. ?photo_id if photo_id is an argument and
#	it is optional.  The arguments are <key,value> pairs,
#	separated by spaces and where any leading dash for the key
#	will be ignored.  Keys are reduced to their closest match, if
#	possible, when parsing.
#
# Arguments:
#	meth	Name of flickr method, used for output
#	spec	Specification of template, see above
#	args	List of space separated key value pairs.
#
# Results:
#	Return the clean and valid list of key and values for the command.
#
# Side Effects:
#	Will raise Tcl errors for all errors.
proc ::flickr::__checkargs { meth spec args } {
    variable log
    variable Flickr

    # Build a specification table with the specification, all
    # specification keywords beginning by a question mark are marked
    # as optional (and there leading ? removed).
    array set specification {}
    foreach s $spec {
	if { [string index $s 0] == "?" } {
	    set s [string trim [string range $s 1 end]]
	    set specification($s) 0
	} else {
	    set specification($s) 1
	}
    }
    
    # Build a table that contains all the values for the parameters
    # that were passed along the command line.  Remove leading dash if
    # necessary.  Check against list of allowed arguments (via the
    # specification table above) and scream on arguments that are not
    # allowed.
    array set cmdargs {}
    foreach { key val } $args {
	if { [string index $key 0] == "-" } {
	    set key [string trim [string range $key 1 end]]
	}
	set possible [array names specification "${key}*"]
	if { [llength $possible] < 0 } {
	    return -code error "$key is not an allowed argument to $meth"
	}
	if { [llength $possible] > 1 } {
	    return -code error "$key is an ambiguous argument could be\
                                any of '$possible'"
	}
	set cmdargs($possible) $val
    }

    # Now use specification as a marker of what was passed along the
    # command line.  Remove from the specification table all optional
    # arguments and all mandatory arguments that were passed along the
    # command line.
    foreach k [array names cmdargs] {
	unset specification($k)
    }
    foreach s [array names specification] {
	if { ! $specification($s) } {
	    unset specification($s)
	}
    }

    # If there is anything remaining in the specification table, then
    # it means that a mandatory argument was missing, scream.
    if { [llength [array names specification]] > 0 } {
	return -code error \
	    "mandatory arguments [array names specification] to $meth missing"
    }

    return [array get cmdargs]
}


# ::flickr::__parse -- Parse in a temporary context
#
#	This command is a tax-compatible callback and is called back
#	during the parsing of flickr answers.  The context is used to
#	store errors when such are parsed.  The command will call the
#	callback stored in the context for results which are not
#	errors.
#
# Arguments:
#	cx	Parsing context
#	tag	XML tag
#	type	Type of tag (O, C or OC)
#	props	Properties of tag
#	bdy	Body of tag
#	tree	XML tree to this tag
#
# Results:
#	None
#
# Side Effects:
#	None.
proc ::flickr::__parse { cx tag type props bdy tree } {
    variable Flickr
    variable log

    upvar \#0 $cx Context
    # Get rid of XML header information, just duplicate it
    if { [string index $tag 0] eq "?" } {
	return
    }
    # The first tag is a false "docstart" tag, ignore it.
    if { [llength $tree] == 0 } {
	return
    }

    set calledback 0
    if { [string first "O" $type] >= 0 } {
	switch $tag {
	    "rsp" {
		set Context(rsp) $props
		set calledback 1
	    }
	    "err" {
		array set Context $props
		set calledback 1
	    }
	}
    }
    if { ! $calledback } {
	array set res $Context(rsp)
	if { $res(stat) == "ok" && $Context(cb) ne "" } {
	    if { [catch {eval $Context(cb) \
			     \$tag \$type \$props \$bdy \$tree} err] } {
		${log}::warn \
		    "Error when calling back during parsing: $err"
	    }
	}
    }
}


# ::flickr::__parseresult -- Parse flickr API call result
#
#	This command will use the tiny tax parser to parse the result
#	of a flickr API call.
#
# Arguments:
#	meth	Method that was called
#	data	XML data result of method call
#	cb	tax-compliant callback that will be called back on successes.
#
# Results:
#	None
#
# Side Effects:
#	Will raise Tcl errors with the description of the flickr error
#	if such occur
proc ::flickr::__parseresult { meth data { cb "" } } {
    variable Flickr
    variable log

    # Create a temporary parsing context and use tax to parse the XML
    # data.
    ${log}::debug "Parsing result of $meth"
    set cx "::flickr::__prs_[incr Flickr(idgene)]"
    upvar \#0 $cx Context
    set Context(cb) $cb
    set parser [::tax::new [list ::flickr::__parse $cx]]
    ::tax::parse $parser $data

    # Analyse the result, via the context and deliver Tcl errors when
    # errors occur as described by flickr.
    array set res $Context(rsp)
    if { $res(stat) == "fail" } {
	set errcode $Context(code)
	set errmsg $Context(msg)
	unset Context
	return -code error "When calling $meth, error code $errcode: $errmsg"
    }
    unset Context
}


# ::flickr::__methodtemplate -- API method caller template
#
#	The command below is not a working procedure in the full
#	Tcl-sense.  Instead, it will be copied and slightly modified
#	for each command dynamically created when declaring flickr API
#	method calls.  In this template, every instance of the string
#	@m@ will be replaced by the full flickr method name; every
#	instance of the string @s@ will be replaced by the list of
#	argument specifications for that method.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	prscb	Tax compatible callback to call when parsing result
#	args	List of arguments to send further to the Flicker call
#
# Results:
#	Return the XML response from flickr
#
# Side Effects:
#	Will perform a REST call.
proc ::flickr::__methodtemplate { cx prscb args } {
    variable Flickr
    variable log

    # Get to context 
    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    upvar \#0 $cx FlickrCx
    
    set callargs [eval __checkargs @m@ [list [list @s@]] $args]
    set res [eval call $cx @m@ @g@ @l@ $callargs]
    if { $res eq "" } {
	return -code error "No response from flickr when calling @m@"
    }
    __parseresult @m@ $res $prscb
    return $res							
}


# ::flickr::__installmeth -- Install a wrapper for a flickr API method
#
#	This command installs in this very namespace a wrapper
#	procedure for calling a flickr API method.  The leading
#	flickr. is removed from the method name and the remaining
#	characters will be the name of the method.  Each created
#	procedure takes three arguments: the flickr context, as
#	created by new, a tax-compatible parsing callback that will be
#	called on the data when the flickr API call has succeeded and
#	any number of arguments as allowed by the method, the api_key
#	argument can always be omitted since it is part of the
#	context.
#
# Arguments:
#	meth	Name of the flickr API method
#	spec	Specification template for the parameters that are allowed
#
# Results:
#	None
#
# Side Effects:
#	None.
proc ::flickr::__installmeth { meth spec { sign off } { login off } } {
    variable Flickr
    variable log

    ${log}::debug "Creating wrapper for method $meth"
    set procname [join [lrange [split $meth "."] 1 end] "."]
    proc ::flickr::$procname [info args ::flickr::__methodtemplate] \
	[string map [list @m@ $meth @s@ $spec @g@ $sign @l@ $login] \
	     [info body ::flickr::__methodtemplate]]
}



# ::flickr::config -- Config an existing Flickr context
#
#	Get or set options for a flickr connection context.
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	args	List of options.
#
# Results:
#	Return all options, the value of the option requested or set
#	the options passed as a parameter.
#
# Side Effects:
#	None.
proc ::flickr::config { cx args } {
    variable Flickr
    variable log

    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    
    upvar \#0 $cx FlickrCx
    set result [eval ::uobj::config FlickrCx "-*" $args]

    return $result
}


# ::flickr::__extractmethod -- Extract method information
#
#	This procedure is designed to be called back by the dynamic
#	method API discovery.  The procedure complies to the callback
#	arguments of the tax parser.  It stores the results of method
#	description into the connection context for further usage..
#
# Arguments:
#	cx	Identifier of connection context as returned by new below
#	tag	Name of tag being called back
#	type	Type of tag (open, close, etc.)
#	props	Properties to tag
#	bdy     Body (content) of tag being parsed
#
# Results:
#	None.
#
# Side Effects:
#	Dynamically modify the connection context
proc ::flickr::__extractmethod {cx tag type props bdy tree} {
    variable Flickr
    variable log

    # Get to connection context.
    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    
    upvar \#0 $cx FlickrCx

    # Analyse the XML. The <method> tag describes the method, if it
    # needs authentification or signing.  There will be as many
    # <argument> tags as there are arguments to the method and these
    # will describe whether they are optional or not.  We store
    # everything in the method index of the connection context array.
    # This is rather ugly, but works.
    if { [string first "O" $type] >= 0 } {
	switch $tag {
	    "method" {
		array set m $props
		lappend FlickrCx(method) method $m(name) auth $m(needslogin) \
		    sign $m(needssigning)
	    }
	    "argument" {
		array set a $props
		if { [string is true $a(optional)] } {
		    lappend FlickrCx(method) optarg $a(name)
		} else {
		    lappend FlickrCx(method) arg $a(name)
		}
	    }
	}
    }
}


# ::flickr::methods -- Generate API
#
#	This procedure uses the reflection API at flickr to discover
#	all existing methods, together with their arguments.  It
#	writes down this API to a "cache" file, that will be read at
#	each library initialisation.  This is something that you, as a
#	user, will never probably have to do, but is here for
#	completion of the code.
#
# Arguments:
#	cx	Identifier of the connection context.
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::flickr::methods { cx } {
    variable Flickr
    variable log
    variable libdir

    if { [info vars $cx] eq "" } {
	${log}::warn "Unknown flickr context $cx"
	return -code error "Unknown flickr context $cx"
    }
    
    upvar \#0 $cx FlickrCx
    set FlickrCx(methods) [list]
    reflection.getMethods $cx [list __extractxml $cx method methods]
    set fname [file join $libdir $Flickr(cache)]
    set fd [open $fname "w"]
    foreach m $FlickrCx(methods) {
	set skip 0
	foreach forbidden $Flickr(skip) {
	    if { [string match $forbidden $m] } {
		set skip 1
	    }
	}
	if { ! $skip } {
	    set FlickrCx(method) [list]
	    reflection.getMethodInfo $cx [list __extractmethod $cx] \
		-method_name $m
	    set method ""
	    set authorization 0
	    set signed 0
	    set args [list]
	    foreach {k v} $FlickrCx(method) {
		switch $k {
		    "method" {
			set method $v
		    }
		    "auth" {
			set authorization $v
		    }
		    "optarg" {
			lappend args "?$v"
		    }
		    "arg" {
			if { $v ne "api_key" } {
			    lappend args $v
			}
		    }
		    "sign" {
			set signed $v
		    }
		}
	    }
	    puts $fd "__installmeth $method \{$args\} $signed $authorization"
	}
    }
    close $fd
}


# ::flickr::new -- Create new context for Flickr connection
#
#	This command returns a new context for a connection to flickr
#	via the REST API.  This context will be used in most of all
#	other commands of this module.
#
# Arguments:
#	args	Additional -key value attributes, see top of file
#
# Results:
#	Identifier for connection
#
# Side Effects:
#	None.
proc ::flickr::new { args } {
    variable Flickr
    variable libdir
    variable log

    set varname "::flickr::cx_[incr Flickr(idgene)]"
    upvar \#0 $varname FlickerCx
	
    set FlickerCx(id) $Flickr(idgene)
    set FlickerCx(token) ""
    ::uobj::inherit Flickr FlickerCx

    if { [info commands ::flickr::photos.*] eq "" } {
	# Reflection
	__installmeth flickr.reflection.getMethodInfo {method_name}
	__installmeth flickr.reflection.getMethods {}

	# Authentication
	__installmeth flickr.auth.checkToken {auth_token} on
	__installmeth flickr.auth.getFrob {} on
	__installmeth flickr.auth.getFullToken {mini_token} on
	__installmeth flickr.auth.getToken {frob} on

	# Dynamically generated API
	set fname [file join $libdir $Flickr(cache)]
	if { [file readable $fname] } {
	    ${log}::notice \
		"Loading in dynamic Flickr API description from $fname"
	    source $fname
	} else {
	    ${log}::error\
		"Could not read dynamic Flickr API description at $fname!"
	}

	# Done, remove the method template.
	rename ::flickr::__methodtemplate ""
    }

    eval config $varname $args

    return $varname
}

package provide flickr 0.2
